Dim crlf$ Dim TblName$ Dim bufsize% Dim SearchMethod% Dim loading% Dim recNbr% Dim pxerr% Dim tblcurrent% Dim nflds% Dim curfld% Dim curfldtype$ Dim curvalue$ Dim pdoxDay% Dim pdoxMth% Dim pdoxYear% Dim indexIDs%(1 To DEFTABLEHANDLES%) Dim slot%(1 To DEFTABLEHANDLES%) Dim tblHandle%(1 To DEFTABLEHANDLES%) Dim recHandle%(1 To DEFTABLEHANDLES%) Dim fldHandle%(1 To DEFTABLEHANDLES%) Dim fnames$() Const thisForm% = 1 Const blanks$ = " " 'Paradox Hardcode 26 for fieldnames !!?? Sub clearit_click () Dim x% grid1.rows = 2 grid1.row = 1 For x% = 1 To grid1.cols - 1 grid1.col = x% grid1.text = "" Next x% grid1.col = 1 Text2.text = "" text4.text = "" text4.SetFocus End Sub Sub Form_Load () Dim retval%, fields% Dim fwidth% Dim NbrKeys% Dim NbrRecs& Dim RecSize% setMousePointer (11) 'set hourglass loading% = TRUE TblName$ = tablename$(thisForm%) bufsize% = 255 alphaval$ = String$(255, " ") tblcurrent% = FALSE For i = 1 To DEFTABLEHANDLES% slot%(i) = FALSE tblHandle%(i) = FALSE recHandle%(i) = FALSE fldHandle%(i) = FALSE Next i text4.text = "" If tableOpen%(TblName$, 0) <> TRUE Then setMousePointer (0) MsgBox pxerrmsg$(pxerr%), 48, "TableOpen Error" loading% = FALSE Text2.text = "Quit" Main.Show Exit Sub End If Load Main.myWin(thisForm%) Main.myWin(thisForm%).Caption = "&" + Format$(thisForm%) + ". " + TblName$ Main.myWin(thisForm%).Visible = TRUE If qFldCount%(nfields%) <> TRUE Then setMousePointer (0) MsgBox pxerrmsg$(pxerr%), 48, "Field Count Error" End If For x% = 1 To nfields% fname$ = blanks$ If qFldName%(x%, fname$) = TRUE Then combo1.AddItem fname$ form1d.sourceflds.AddItem fname$ 'Hardcode ???! Else MsgBox pxerrmsg$(pxerr%), 48, "Field Name Error" Exit Sub End If Next Caption = UCase$(TblName$) + " Table" combo1.listindex = 0 setMousePointer (0) form1d.Show MODAL% nflds% = form1d.displayflds.listcount 'number of display fields If nflds% = 0 Then Quit_Click 'press quit button loading% = FALSE Exit Sub 'bail out. End If Show ReDim fnames$(nflds%) If qNbrKeyFlds%(NbrKeys%) <> TRUE Then tKeyFlds.text = Format$(0) Else tKeyFlds.text = Format$(NbrKeys%) End If If qRecCount%(NbrRecs&) <> TRUE Then tTotRecs.text = Format$(0) Else tTotRecs.text = Format$(NbrRecs&) End If If qRecSize%(RecSize%) <> TRUE Then tRecLen.text = Format$(0) Else tRecLen.text = Format$(RecSize%) End If grid1.cols = nflds% + 1 grid1.rows = 2 grid1.row = 0 grid1.col = 0 grid1.text = " " grid1.colwidth = 120 * Len(grid1.text) For x% = 1 To nflds% 'build display width grid1.col = x% fnames$(x%) = form1d.displayflds.list(x% - 1) If qFldType(fnames$(x%), ftype$) <> TRUE Then MsgBox pxerrmsg$(pxerr%), 48, "Field Type Error" Else Select Case ftype$ Case "A" grid1.colalignment = 0 Case "N" grid1.colalignment = 2 Case "S" grid1.colalignment = 2 Case "$" grid1.colalignment = 2 Case "D" grid1.colalignment = 1 End Select End If grid1.text = fnames$(x%) retval% = qFldSize%(fnames$(x%), fwidth%) If fwidth% < Len(fnames$(x%)) Then fwidth% = Len(fnames$(x%)) End If grid1.colwidth = 120 * fwidth% Next x% grid1.col = 1 grid1.row = grid1.row + 1 text4.SetFocus loading% = FALSE End Sub Sub NextOne_Click () If GotoRecNbr%(NEXTRec&) <> TRUE Then MsgBox pxerrmsg$(pxerr%), 48, "Next Record Error" Exit Sub End If If getRec%() <> TRUE Then MsgBox pxerrmsg$(pxerr%), 48, "Record Read Error" Exit Sub End If grid1.row = grid1.rows - 1 displayrec ' grid1.rows = grid1.rows + 1 grid1.rows = grid1.rows + 1 If grid1.rows >= 10 Then grid1.topRow = grid1.rows - 10 Else grid1.topRow = 1 End If End Sub Sub displayrec () For x% = 1 To nflds% grid1.col = x% If getFld%(fnames$(x%), fldVal$) <> TRUE Then MsgBox pxerrmsg$(pxerr%), 48, "Record Read Error" Exit Sub End If grid1.text = fldVal$ Next x% Text2.text = Str$(grid1.rows - 1) End Sub Sub PrevOne_Click () If GotoRecNbr%(PREVRec&) <> TRUE Then MsgBox pxerrmsg$(pxerr%), 48, "Previous Record Error" Exit Sub End If If getRec%() <> TRUE Then MsgBox pxerrmsg$(pxerr%), 48, "Record Read Error" Exit Sub End If grid1.row = grid1.rows - 1 displayrec ' grid1.rows = grid1.rows + 1 grid1.rows = grid1.rows + 1 If grid1.rows >= 10 Then grid1.topRow = grid1.rows - 10 Else grid1.topRow = 1 End If End Sub Sub Picture1_Click () Picture1.Visible = FALSE Picture2.Visible = TRUE End Sub Sub Picture2_Click () Picture2.Visible = FALSE Picture1.Visible = TRUE End Sub Function tableOpen% (TblName$, indexID%) pxerr% = pxtblexist%(TblName$, exists%) If pxerr% <> PXSUCCESS% Then tableOpen% = FALSE Else If exists% = FALSE Then tableOpen% = FALSE pxerr% = 5 Else If logtable%() = TRUE Then pxerr% = PxTblOpen%(TblName$, tHandle%, indexID%, 0) If pxerr% <> PXSUCCESS% Then tableOpen% = FALSE Else tblHandle%(tblcurrent%) = tHandle% pxerr% = PxRecBufOpen%(tblHandle%(tblcurrent%), rHandle%) If pxerr% <> PXSUCCESS% Then tableOpen% = FALSE Else recHandle%(tblcurrent%) = rHandle% tableOpen% = TRUE End If End If Else MsgBox "Too many tables open.", 64, "Log Error" End If End If End If End Function Function tableClose% () pxerr% = pxTblClose(tblHandle%(tblcurrent%)) If pxerr% <> PXSUCCESS% Then tableClose% = FALSE Else tableClose% = TRUE logouttable (tblcurrent%) End If End Function Function qCurRecNbr& () Dim recNbr& pxerr% = PXRecNum%(tblHandle%(tblcurrent%), recNbr&) If pxerr% <> PXSUCCESS% Then qCurRecNbr& = FALSE Else qCurRecNbr& = recNbr& End If End Function Function GotoRecNbr% (recNbr&) Select Case recNbr& Case LASTRec pxerr% = PxRecLast%(tblHandle%(tblcurrent%)) If pxerr% <> PXSUCCESS% Then GotoRecNbr% = FALSE Else GotoRecNbr% = TRUE End If Case FIRSTRec pxerr% = PxRecFirst%(tblHandle%(tblcurrent%)) If pxerr% <> PXSUCCESS% Then GotoRecNbr% = FALSE Else GotoRecNbr% = TRUE End If Case NEXTRec pxerr% = PxRecNext%(tblHandle%(tblcurrent%)) If pxerr% <> PXSUCCESS% Then GotoRecNbr% = FALSE Else GotoRecNbr% = TRUE End If Case PREVRec pxerr% = PxRecPrev%(tblHandle%(tblcurrent%)) If pxerr% <> PXSUCCESS% Then GotoRecNbr% = FALSE Else GotoRecNbr% = TRUE End If Case Else pxerr% = PxRecGoto%(tblHandle%(tblcurrent%), recNbr&) If pxerr% <> PXSUCCESS% Then GotoRecNbr% = FALSE Else GotoRecNbr% = TRUE End If End Select End Function Function tblSearch% (fname$, Value$, srchMethod%) pxerr% = PxRecBufEmpty%(recHandle%(tblcurrent%)) If pxerr% <> PXSUCCESS% Then tblSearch% = FALSE Exit Function End If If PutFld%(fname$, Value$) <> TRUE Then tblSearch% = FALSE Exit Function End If pxerr% = PxSrchFld%(tblHandle%(tblcurrent%), recHandle%(tblcurrent%), fldHandle%(tblcurrent%), srchMethod%) If pxerr% <> PXSUCCESS% Then If pxerr% <> PXERR_RECNOTFOUND% Then 'EOF??!! tblSearch% = FALSE Exit Function End If End If tblSearch% = TRUE End Function Function getRec% () pxerr% = PxRecGet(tblHandle%(tblcurrent%), recHandle%(tblcurrent%)) If pxerr% <> PXSUCCESS% Then getRec% = FALSE Else getRec% = TRUE End If End Function Function NewRec% () pxerr% = PxRecBufEmpty%(recHandle%(tblcurrent%)) If pxerr% <> PXSUCCESS Then NewRec% = FALSE Else NewRec% = TRUE End If End Function Function getFld% (fname$, fldbuf$) pxerr% = PxFldHandle%(tblHandle%(tblcurrent%), fname$, fHandle%) If pxerr% <> PXSUCCESS% Then getFld% = FALSE Exit Function End If fldHandle%(tblcurrent%) = fHandle% fldtype$ = String$(5, " ") pxerr% = PxFldType%(tblHandle%(tblcurrent%), fldHandle%(tblcurrent%), 5, fldtype$) If pxerr% <> PXSUCCESS% Then getFld% = FALSE Exit Function End If Select Case Left$(fldtype$, 1) Case "A" strbuf$ = String$(255, " ") pxerr% = PxGetAlpha%(recHandle%(tblcurrent%), fldHandle%(tblcurrent%), Len(strbuf$), strbuf$) If pxerr% <> PXSUCCESS% Then getFld% = FALSE Else getFld% = TRUE fldbuf$ = RTrim$(strbuf$) fldbuf$ = Left$(fldbuf$, (Len(fldbuf$) - 1)) 'trailing \0' End If Case "N", "$" pxerr% = PxGetDoub%(recHandle%(tblcurrent%), fldHandle%(tblcurrent%), dblbuf#) If pxerr% <> PXSUCCESS% Then getFld% = FALSE Else getFld% = TRUE If Left$(fldtype$, 1) = "$" Then fldbuf$ = Format$(dblbuf#, "#,##0.00") Else fldbuf$ = Str$(dblbuf#) End If End If Case "S" pxerr% = PxGetShort%(recHandle%(tblcurrent%), fldHandle%(tblcurrent%), shortbuf%) If pxerr% <> PXSUCCESS% Then getFld% = FALSE Else getFld% = TRUE fldbuf$ = Str$(shortbuf%) End If Case "D" pxerr% = PxGetDate%(recHandle%(tblcurrent%), fldHandle%(tblcurrent%), longbuf&) If pxerr% <> PXSUCCESS% Then getFld% = FALSE Else pxerr% = PxDateDecode%(longbuf&, pdoxMth%, pdoxDay%, pdoxYear%) If pxerr% <> PXSUCCESS% Then getFld% = FALSE Else pdoxYear% = pdoxYear% - 1900 '!!??! fldbuf$ = Format$(pdoxMth%) + "/" + Format$(pdoxDay%) + "/" + Format$(pdoxYear%) getFld% = TRUE End If End If End Select End Function Function PutFld% (fname$, fldbuf$) Dim datebuf& pxerr% = PxFldHandle%(tblHandle%(tblcurrent%), fname$, fHandle%) If pxerr% <> PXSUCCESS% Then PutFld% = FALSE Exit Function End If fldtype$ = String$(5, 0) fldHandle%(tblcurrent%) = fHandle% pxerr% = PxFldType%(tblHandle%(tblcurrent%), fldHandle%(tblcurrent%), 5, fldtype$) If pxerr% <> PXSUCCESS% Then PutFld% = FALSE Exit Function End If Select Case Left$(fldtype$, 1) Case "A" pxerr% = PxPutAlpha%(recHandle%(tblcurrent%), fldHandle%(tblcurrent%), fldbuf$) If pxerr% <> PXSUCCESS% Then PutFld% = FALSE Else PutFld% = TRUE End If Case "N", "$" dblbuf# = Val(fldbuf$) pxerr% = PxPutDoub%(recHandle%(tblcurrent%), fldHandle%(tblcurrent%), dblbuf#) If pxerr% <> PXSUCCESS% Then PutFld% = FALSE Else PutFld% = TRUE End If Case "S" shortbuf% = Val(fldbuf$) pxerr% = PxPutShort%(recHandle%(tblcurrent%), fldHandle%(tblcurrent%), shortbuf%) If pxerr% <> PXSUCCESS% Then PutFld% = FALSE Else PutFld% = TRUE End If Case "D" If ConvertDte%(fldbuf$, pdoxMth%, pdoxDay%, pdoxYear%) <> TRUE Then PutFld% = FALSE Else pxerr% = PxDateEncode%(pdoxMth%, pdoxDay%, pdoxYear%, datebuf&) If pxerr% <> PXSUCCESS% Then PutFld% = FALSE Else pxerr% = PxPutDate%(recHandle%(tblcurrent%), fldHandle%(tblcurrent%), datebuf&) If pxerr% <> PXSUCCESS% Then PutFld% = FALSE Else PutFld% = TRUE End If End If End If End Select End Function Function ConvertDte% (datestr$, mth%, dy%, yr%) Dim pos% pos% = InStr(datestr$, "/") mth% = Val(Left$(datestr$, pos% - 1)) datestr$ = Mid$(datestr$, pos% + 1, Len(datestr$) - pos%) pos% = InStr(datestr$, "/") dy% = Val(Left$(datestr$, pos% - 1)) yr% = Val(Mid$(datestr$, pos% + 1, Len(datestr$) - pos%)) + 1900 ConvertDte = TRUE End Function Function FldBlank% (fname$) pxerr% = PxFldHandle%(tblHandle%(tblcurrent%), fname$, fHandle%) If pxerr% <> PXSUCCESS% Then FldBlank% = FALSE Else fldHandle%(tblcurrent%) = fHandle% pxerr% = PxPutBlank%(recHandle%(tblcurrent%), fldHandle%(tblcurrent%)) If pxerr% <> PXSUCCESS% Then FldBlank% = FALSE Else FldBlank% = TRUE End If End If End Function Function IsFldBlank% (fname$) Dim blanktest% pxerr% = PxFldHandle%(tblHandle%(tblcurrent%), fname$, fHandle%) If pxerr% <> PXSUCCESS% Then IsFldBlank% = FALSE Else fldHandle%(tblcurrent%) = fHandle% pxerr% = PxFldBlank%(recHandle(tblcurrent%), fldHandle%(tblcurrent%), blanktest%) If pxerr% <> PXSUCCESS% Then MsgBox pxerrmsg$(pxerr%), 48, "Blank Test Error" Exit Function End If IsFldBlank% = blanktest% End If End Function Function recInsert% () pxerr% = PxRecInsert%(tblHandle%(tblcurrent%), recHandle%(tblcurrent%)) If pxerr% <> PXSUCCESS% Then recInsert% = FALSE Else recInsert% = TRUE End If End Function Function recUpdate% () pxerr% = PxRecUpdate%(tblHandle%(tblcurrent%), recHandle%(tblcurrent%)) If pxerr% <> PXSUCCESS% Then recUpdate% = FALSE Else recUpdate% = TRUE End If End Function Function recDelete% () pxerr% = PxRecDelete%(tblHandle%(tblcurrent%)) If pxerr% <> PXSUCCESS% Then recDelete% = FALSE Else recDelete% = TRUE End If End Function Function qRecCount% (nRecs&) pxerr% = pxTblNRecs(tblHandle%(tblcurrent%), nRecs&) If pxerr% <> PXSUCCESS% Then qRecCount% = FALSE Else qRecCount% = TRUE End If End Function Sub logouttable (lognbr%) slot%(lognbr%) = FALSE If tblcurrent% = lognbr% Then tlbcurrent% = 0 End If End Sub Function logtable% () done = FALSE i = 1 Do While done = FALSE And i < DEFTABLEHANDLES% If slot%(i) = FALSE Then slot%(i) = TRUE tblcurrent% = i logtable% = TRUE done = TRUE Exit Function Else i = i + 1 End If Loop logtable% = FALSE End Function Sub tblSelect (lognbr%) tblcurrent% = lognbr% 'do we need this??!? End Sub Function QtblCurrent% () QtblCurrent% = tblcurrent% 'do we need this ??!? End Function Function qFldCount% (nflds%) pxerr% = pxRecNFlds%(tblHandle%(tblcurrent%), nflds%) If pxerr% <> PXSUCCESS% Then qFldCount% = FALSE Else qFldCount% = TRUE End If End Function Function qFldName% (fHandle%, fname$) pxerr% = PxFldName%(tblHandle%(tblcurrent%), fHandle%, Len(fname$), fname$) If pxerr% <> PXSUCCESS% Then qFldName% = FALSE Else qFldName% = TRUE End If End Function Function qFldSize% (fname$, fsize%) pxerr% = PxFldHandle%(tblHandle%(tblcurrent%), fname$, fHandle%) If pxerr% <> PXSUCCESS% Then qFldSize% = FALSE Exit Function End If fldtype$ = String$(5, " ") fldHandle%(tblcurrent%) = fHandle% pxerr% = PxFldType%(tblHandle%(tblcurrent%), fldHandle%(tblcurrent%), 5, fldtype$) If pxerr% <> PXSUCCESS% Then qFldSize% = FALSE Exit Function End If Select Case Left$(fldtype$, 1) Case "A" fsize% = Val(Mid$(fldtype$, 2, 3)) Case "N", "$" fsize% = 9 '??!? Case "S" fsize% = 8 '??!? Case "D" fsize% = 8 '??!? End Select qFldSize% = TRUE End Function Sub Combo1_Click () If loading% = TRUE Then 'can't unload during load event. Exit Sub End If NewID% = combo1.listindex + 1 If NewID% = indexIDs%(tblcurrent%) Then Exit Sub 'don't change index to itself... End If indexIDs%(tblcurrent%) = NewID% If tableClose%() <> TRUE Then MsgBox pxerrmsg$(pxerr%), 48, "Table Close Error" Else SavedMousePointer = Screen.MousePointer Screen.MousePointer = 11 If tableOpen%(TblName$, NewID%) <> TRUE Then If pxerr% >= 121 And pxerr% <= 124 Then If tableOpen%(TblName$, 0) <> TRUE Then MsgBox pxerrmsg$(pxerr%), 48, "Open Error" Else SearchMethod% = SearchFirst% indexIDs%(tblcurrent%) = 0 End If Else MsgBox pxerrmsg$(pxerr%), 48, "Open Error" End If Else SearchMethod% = ClosestRecord% End If text4.text = "" text4.SetFocus Screen.MousePointer = SavedMousePointer End If End Sub Sub First_Click () If GotoRecNbr%(FIRSTRec&) = TRUE Then If getRec%() <> TRUE Then MsgBox pxerrmsg$(pxerr%), 48, "Read Error" Else grid1.row = grid1.rows - 1 displayrec ' grid1.rows = grid1.rows + 1 grid1.rows = grid1.rows + 1 If grid1.rows >= 10 Then grid1.topRow = grid1.rows - 10 Else grid1.topRow = 1 End If End If Else MsgBox pxerrmsg$(pxerr%), 48, "First Record Error" End If End Sub Sub Last_Click () If GotoRecNbr%(LASTRec&) = TRUE Then If getRec%() <> TRUE Then MsgBox pxerrmsg$(pxerr%), 48, "Read Error" Else grid1.row = grid1.rows - 1 displayrec ' grid1.rows = grid1.rows + 1 grid1.rows = grid1.rows + 1 If grid1.rows >= 10 Then grid1.topRow = grid1.rows - 10 Else grid1.topRow = 1 End If End If Else MsgBox pxerrmsg$(pxerr%), 48, "First Record Error" End If End Sub Sub Search_Click () Dim searchVal$, fname$ searchVal$ = text4.text fname$ = combo1.text If tblSearch%(fname$, searchVal$, SearchMethod%) = TRUE Then If getRec%() <> TRUE Then MsgBox pxerrmsg$(pxerr%), 48, "Record Read Error" Exit Sub End If grid1.row = grid1.rows - 1 displayrec grid1.rows = grid1.rows + 1 If grid1.rows >= 10 Then grid1.topRow = grid1.rows - 10 Else grid1.topRow = 1 End If End If text4.SetFocus End Sub Sub Quit_Click () inuse%(thisForm%) = FALSE 'hard coded ????! If tableClose%() <> TRUE Then MsgBox pxerrmsg$(pxerr%), 48, "Table Close Error" End If ' change mouse to hourglass !!!!? Main.myWin(thisForm%).Visible = FALSE Unload Main.myWin(thisForm%) If loading% = TRUE Then Text2.text = "Quit" 'problem with unload during Else 'a load sub??? Unload Form1 'hardcoded ???!! End If End Sub Function qFldType% (fname$, ftype$) pxerr% = PxFldHandle%(tblHandle%(tblcurrent%), fname$, fHandle%) If pxerr% <> PXSUCCESS% Then qFldType% = FALSE Exit Function End If fldtype$ = String$(5, " ") fldHandle%(tblcurrent%) = fHandle% pxerr% = PxFldType%(tblHandle%(tblcurrent%), fldHandle%(tblcurrent%), 5, fldtype$) If pxerr% <> PXSUCCESS% Then qFldType% = FALSE Exit Function End If ftype$ = Left$(fldtype$, 1) qFldType% = TRUE End Function Function qNbrKeyFlds% (NbrKeys%) pxerr% = PxKeyNFlds%(tblHandle%(tblcurrent%), NbrKeys%) If pxerr% <> PXSUCCESS% Then MsgBox pxerrmsg$(pxerr%), 48, "Error Checking Key Fields" qNbrKeyFlds% = FALSE Else qNbrKeyFlds% = TRUE End If End Function Function qRecSize% (RecLen%) Dim retval% Dim nfields% Dim x% Dim fldname$ Dim fldtype$ Dim fldsize% RecLen% = 0 retval% = qFldCount(nfields%) For x% = 1 To nfields% fldname$ = blanks$ '26 spaces for fname retval% = qFldName%(x%, fldname$) retval% = qFldType%(fldname$, fldtype$) Select Case fldtype$ Case "A" retval% = qFldSize(fldname$, fldsize%) RecLen% = RecLen% + fldsize% Case "D" RecLen% = RecLen% + 2 Case "S" RecLen% = RecLen% + 4 Case "N" RecLen% = RecLen% + 8 Case "$" RecLen% = RecLen% + 8 End Select Next x% qRecSize% = TRUE End Function